home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / schemify.pso < prev    next >
Encoding:
Text File  |  1992-02-17  |  9.1 KB  |  195 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2.  
  3. ; This file was generated by Pseudoscheme 2.8a
  4. ;  running in Lucid Common Lisp 4.0.1
  5. ;  from file /amd/night/b/jar/pseudo/schemify.scm
  6.  
  7. (SCHI:BEGIN-TRANSLATED-FILE)
  8. (DEFUN SCHEMIFY-TOP
  9.        (NODE)
  10.        (SCHEMIFY NODE 'NIL))
  11. (SCHI:SET-VALUE-FROM-FUNCTION 'SCHEMIFY-TOP
  12.                               'SCHEME::SCHEMIFY-TOP)
  13. (DEFUN SCHEMIFY
  14.        (NODE ENV)
  15.        (IF (SCHI:TRUEP (NODE? NODE))
  16.            (CASE (NODE-TYPE NODE)
  17.                  ((SCHEME::PROGRAM-VARIABLE) (PROGRAM-VARIABLE-NAME NODE))
  18.                  ((SCHEME::LOCAL-VARIABLE)
  19.                    (LET ((PROBE (SCHI:TRUE? (ASSOC NODE ENV :TEST #'EQ))))
  20.                      (IF (SCHI:TRUEP PROBE)
  21.                          (CDR PROBE)
  22.                          (LOCAL-VARIABLE-NAME NODE))))
  23.                  ((SCHEME::CALL) (SCHEMIFY-CALL NODE ENV))
  24.                  ((SCHEME::CONSTANT)
  25.                    (LET ((VAL (CONSTANT-VALUE NODE)))
  26.                      (IF (OR (NUMBERP VAL)
  27.                              (CHARACTERP VAL)
  28.                              (SIMPLE-STRING-P VAL)
  29.                              (SCHI:BOOLEANP VAL))
  30.                          VAL
  31.                          (CONS 'SCHEME::QUOTE
  32.                                (LIST VAL)))))
  33.                  ((SCHEME::LAMBDA)
  34.                    (LET ((VARS (LAMBDA-VARS NODE)))
  35.                      (LET ((NEW-VARS
  36.                              (MAPCAR
  37.                                #'(LAMBDA (VAR) (EXTERNALIZE-VARIABLE VAR ENV))
  38.                                VARS)))
  39.                        (CONS 'SCHEME::LAMBDA
  40.                              (CONS NEW-VARS
  41.                                    (SCHEMIFY-BODY (LAMBDA-BODY NODE)
  42.                                                   (SCHEMIFY-BIND VARS
  43.                                                                  NEW-VARS
  44.                                                                  ENV)))))))
  45.                  ((SCHEME::LETREC)
  46.                    (LET ((VARS (LETREC-VARS NODE)))
  47.                      (LET ((VALS (LETREC-VALS NODE)))
  48.                        (LET ((NEW-VARS
  49.                                (MAPCAR
  50.                                  #'(LAMBDA (VAR)
  51.                                     (EXTERNALIZE-VARIABLE VAR ENV))
  52.                                  VARS)))
  53.                          (LET ((ENV@0 (SCHEMIFY-BIND VARS NEW-VARS ENV)))
  54.                            (CONS 'SCHEME::LETREC
  55.                                  (CONS
  56.                                    (MAPCAR
  57.                                      #'(LAMBDA (VAR VAL)
  58.                                         (CONS VAR
  59.                                          (LIST (SCHEMIFY VAL ENV@0))))
  60.                                      NEW-VARS
  61.                                      VALS)
  62.                                    (SCHEMIFY-BODY (LETREC-BODY NODE)
  63.                                                   ENV@0))))))))
  64.                  ((SCHEME::IF)
  65.                    (LET ((TEST (SCHEMIFY (IF-TEST NODE)
  66.                                          ENV))
  67.                          (CON (SCHEMIFY (IF-CON NODE) ENV))
  68.                          (ALT (SCHEMIFY (IF-ALT NODE) ENV)))
  69.                      (CONS 'SCHEME::IF
  70.                            (CONS TEST
  71.                                  (CONS CON (LIST ALT))))))
  72.                  ((SCHEME::SET!)
  73.                    (CONS 'SCHEME::SET!
  74.                          (CONS (SCHEMIFY (SET!-LHS NODE)
  75.                                          ENV)
  76.                                (LIST (SCHEMIFY (SET!-RHS NODE)
  77.                                                ENV)))))
  78.                  ((SCHEME::BEGIN)
  79.                    (CONS 'SCHEME::BEGIN
  80.                          (CONS (SCHEMIFY (BEGIN-FIRST NODE)
  81.                                          ENV)
  82.                                (UNBEGINIFY
  83.                                  (SCHEMIFY (BEGIN-SECOND NODE)
  84.                                            ENV)))))
  85.                  ((SCHEME::DEFINE)
  86.                    (LET ((VAR (SCHEMIFY (DEFINE-LHS NODE)
  87.                                         ENV)))
  88.                      (IF (NOT (SCHI:SCHEME-SYMBOL-P VAR))
  89.                          (.ERROR "defining a non-variable -- shouldn't happen"
  90.                                  VAR))
  91.                      (CONS 'SCHEME::DEFINE
  92.                            (CONS VAR
  93.                                  (LIST (SCHEMIFY (DEFINE-RHS NODE)
  94.                                                  ENV))))))
  95.                  (OTHERWISE (CONS 'SCHEME::UNKNOWN-NODE-TYPE
  96.                                   (LIST NODE))))
  97.            NODE))
  98. (SCHI:SET-VALUE-FROM-FUNCTION 'SCHEMIFY
  99.                               'SCHEME::SCHEMIFY)
  100. (DEFUN SCHEMIFY-CALL
  101.        (NODE ENV)
  102.        (DECLARE (SPECIAL REVISED^4-SCHEME-ENV))
  103.        (LET ((PROC (CALL-PROC NODE)))
  104.          (LET ((ARGS (CALL-ARGS NODE)))
  105.            (FLET
  106.              ((PUNT NIL
  107.                     (CONS (SCHEMIFY PROC ENV)
  108.                           (MAPCAR
  109.                             #'(LAMBDA (SUBNODE) (SCHEMIFY SUBNODE ENV))
  110.                             ARGS))))
  111.              (CASE (NODE-TYPE PROC)
  112.                    ((SCHEME::LAMBDA)
  113.                      (LET ((PROC-EXP (SCHEMIFY PROC ENV)))
  114.                        (CONS 'SCHEME::LET
  115.                              (CONS
  116.                                (MAPCAR
  117.                                  #'(LAMBDA (VAR ARG)
  118.                                     (CONS VAR (LIST (SCHEMIFY ARG ENV))))
  119.                                  (CADR PROC-EXP)
  120.                                  ARGS)
  121.                                (CDDR PROC-EXP)))))
  122.                    ((SCHEME::PROGRAM-VARIABLE)
  123.                      (IF (EQ (PROGRAM-VARIABLE-CL-SYMBOL PROC)
  124.                              (PROGRAM-ENV-LOOKUP REVISED^4-SCHEME-ENV
  125.                                                  'SCHEME::AND-AUX))
  126.                          (CONS 'SCHEME::AND
  127.                                (CONS (SCHEMIFY (CAR ARGS) ENV)
  128.                                      (LIST (DETHUNKIFY (CADR ARGS)
  129.                                                        ENV))))
  130.                          (IF (EQ (PROGRAM-VARIABLE-CL-SYMBOL PROC)
  131.                                  (PROGRAM-ENV-LOOKUP REVISED^4-SCHEME-ENV
  132.                                                      'SCHEME::OR-AUX))
  133.                              (CONS 'SCHEME::OR
  134.                                    (CONS (SCHEMIFY (CAR ARGS) ENV)
  135.                                          (LIST (DETHUNKIFY (CADR ARGS)
  136.                                                            ENV))))
  137.                              (IF (EQ (PROGRAM-VARIABLE-CL-SYMBOL PROC)
  138.                                      (PROGRAM-ENV-LOOKUP REVISED^4-SCHEME-ENV
  139.                                                          'SCHEME::CASE-AUX))
  140.                                  (CONS 'SCHEME::CASE
  141.                                        (CONS (SCHEMIFY (CAR ARGS)
  142.                                                        ENV)
  143.                                              (APPEND
  144.                                                (MAPCAR
  145.                                                  #'(LAMBDA (KEYS ARG)
  146.                                                     (CONS KEYS
  147.                                                      (UNBEGINIFY
  148.                                                       (DETHUNKIFY ARG ENV))))
  149.                                                  (CONSTANT-VALUE (CADR ARGS))
  150.                                                  (CDDDR ARGS))
  151.                                                (LIST
  152.                                                  (CONS 'SCHEME::ELSE
  153.                                                        (LIST
  154.                                                          (DETHUNKIFY
  155.                                                            (CADDR ARGS)
  156.                                                            ENV)))))))
  157.                                  (PUNT)))))
  158.                    (OTHERWISE (PUNT)))))))
  159. (SCHI:SET-VALUE-FROM-FUNCTION 'SCHEMIFY-CALL
  160.                               'SCHEME::SCHEMIFY-CALL)
  161. (DEFUN DETHUNKIFY
  162.        (NODE ENV)
  163.        (IF (AND (SCHI:TRUEP (LAMBDA? NODE))
  164.                 (NULL (LAMBDA-VARS NODE)))
  165.            (SCHEMIFY (LAMBDA-BODY NODE) ENV)
  166.            (LIST (SCHEMIFY NODE ENV))))
  167. (SCHI:SET-VALUE-FROM-FUNCTION 'DETHUNKIFY
  168.                               'SCHEME::DETHUNKIFY)
  169. (DEFUN SCHEMIFY-BODY
  170.        (NODE ENV)
  171.        (UNBEGINIFY (SCHEMIFY NODE ENV)))
  172. (SCHI:SET-VALUE-FROM-FUNCTION 'SCHEMIFY-BODY
  173.                               'SCHEME::SCHEMIFY-BODY)
  174. (DEFUN UNBEGINIFY
  175.        (.EXP)
  176.        (IF (SCHI:TRUEP (CAR-IS? .EXP 'SCHEME::BEGIN))
  177.            (CDR .EXP)
  178.            (LIST .EXP)))
  179. (SCHI:SET-VALUE-FROM-FUNCTION 'UNBEGINIFY
  180.                               'SCHEME::UNBEGINIFY)
  181. (DEFUN EXTERNALIZE-VARIABLE
  182.        (VAR ENV)
  183.        (LET ((NAME (LOCAL-VARIABLE-NAME VAR)))
  184.          (IF (SCHI:TRUEP (RASSQ NAME ENV))
  185.              (MAKE-NAME-FROM-UID NAME (GENERATE-UID))
  186.              NAME)))
  187. (SCHI:SET-VALUE-FROM-FUNCTION 'EXTERNALIZE-VARIABLE
  188.                               'SCHEME::EXTERNALIZE-VARIABLE)
  189. (DEFUN SCHEMIFY-BIND
  190.        (VARS NAMES ENV)
  191.        (APPEND (MAPCAR #'CONS VARS NAMES)
  192.                ENV))
  193. (SCHI:SET-VALUE-FROM-FUNCTION 'SCHEMIFY-BIND
  194.                               'SCHEME::SCHEMIFY-BIND)
  195.